home *** CD-ROM | disk | FTP | other *** search
/ Clickx 115 / Clickx 115.iso / software / tools / windows / tails-i386-0.16.iso / live / filesystem.squashfs / usr / share / uim / lib / srfi-95.scm < prev    next >
Encoding:
Text File  |  2010-11-07  |  6.9 KB  |  214 lines
  1. ;;; "sort.scm" Defines: sorted?, merge, merge!, sort, sort!
  2. ;;; Author : Richard A. O'Keefe (based on Prolog code by D.H.D.Warren)
  3. ;;;
  4. ;;; This code is in the public domain.
  5.  
  6. ;;; Updated: 11 June 1991
  7. ;;; Modified for scheme library: Aubrey Jaffer 19 Sept. 1991
  8. ;;; Updated: 19 June 1995
  9. ;;; (sort, sort!, sorted?): Generalized to strings by jaffer: 2003-09-09
  10. ;;; (sort, sort!, sorted?): Generalized to arrays by jaffer: 2003-10-04
  11. ;;; jaffer: 2006-10-08:
  12. ;;; (sort, sort!, sorted?, merge, merge!): Added optional KEY argument.
  13. ;;; jaffer: 2006-11-05:
  14. ;;; (sorted?, merge, merge!, sort, sort!): Call KEY arg at most once
  15. ;;; per element.
  16. ;;; jaffer: 2007-01-29: Final SRFI-95.
  17.  
  18. ;;; Copyright (c) 2007-2008 SigScheme Project <uim-en AT googlegroups.com>
  19.  
  20. ;; ChangeLog
  21. ;;
  22. ;; 2007-07-13 yamaken   - Imported from SLIB CVS HEAD (revision 1.14)
  23. ;;                        http://cvs.savannah.gnu.org/viewvc/*checkout*/slib/slib/sort.scm?revision=1.14
  24. ;;                        and adapted to SigScheme
  25.  
  26.  
  27. ;;(require 'array)
  28.  
  29. ;; For SigScheme
  30. (define array?
  31.   (if (symbol-bound? 'array?)
  32.       (symbol-value 'array)
  33.       (lambda (x) #f)))
  34. (define identity
  35.   (if (symbol-bound? 'identity)
  36.       (symbol-value 'identity)
  37.       (lambda (x) x)))
  38.  
  39. ;;; (sorted? sequence less?)
  40. ;;; is true when sequence is a list (x0 x1 ... xm) or a vector #(x0 ... xm)
  41. ;;; such that for all 1 <= i <= m,
  42. ;;;    (not (less? (list-ref list i) (list-ref list (- i 1)))).
  43. ;@
  44. (define (sorted? seq less? . opt-key)
  45.   (define key (if (null? opt-key) identity (car opt-key)))
  46.   (cond ((null? seq) #t)
  47.     ((array? seq)
  48.      (let ((dimax (+ -1 (car (array-dimensions seq)))))
  49.        (or (<= dimax 1)
  50.            (let loop ((idx (+ -1 dimax))
  51.               (last (key (array-ref seq dimax))))
  52.          (or (negative? idx)
  53.              (let ((nxt (key (array-ref seq idx))))
  54.                (and (less? nxt last)
  55.                 (loop (+ -1 idx) nxt))))))))
  56.     ((null? (cdr seq)) #t)
  57.     (else
  58.      (let loop ((last (key (car seq)))
  59.             (next (cdr seq)))
  60.        (or (null? next)
  61.            (let ((nxt (key (car next))))
  62.          (and (not (less? nxt last))
  63.               (loop nxt (cdr next)))))))))
  64.  
  65. ;;; (merge a b less?)
  66. ;;; takes two lists a and b such that (sorted? a less?) and (sorted? b less?)
  67. ;;; and returns a new list in which the elements of a and b have been stably
  68. ;;; interleaved so that (sorted? (merge a b less?) less?).
  69. ;;; Note:  this does _not_ accept arrays.  See below.
  70. ;@
  71. (define (merge a b less? . opt-key)
  72.   (define key (if (null? opt-key) identity (car opt-key)))
  73.   (cond ((null? a) b)
  74.     ((null? b) a)
  75.     (else
  76.      (let loop ((x (car a)) (kx (key (car a))) (a (cdr a))
  77.             (y (car b)) (ky (key (car b))) (b (cdr b)))
  78.        ;; The loop handles the merging of non-empty lists.  It has
  79.        ;; been written this way to save testing and car/cdring.
  80.        (if (less? ky kx)
  81.            (if (null? b)
  82.            (cons y (cons x a))
  83.            (cons y (loop x kx a (car b) (key (car b)) (cdr b))))
  84.            ;; x <= y
  85.            (if (null? a)
  86.            (cons x (cons y b))
  87.            (cons x (loop (car a) (key (car a)) (cdr a) y ky b))))))))
  88.  
  89. (define (sort:merge! a b less? key)
  90.   (define (loop r a kcara b kcarb)
  91.     (cond ((less? kcarb kcara)
  92.        (set-cdr! r b)
  93.        (if (null? (cdr b))
  94.            (set-cdr! b a)
  95.            (loop b a kcara (cdr b) (key (cadr b)))))
  96.       (else                ; (car a) <= (car b)
  97.        (set-cdr! r a)
  98.        (if (null? (cdr a))
  99.            (set-cdr! a b)
  100.            (loop a (cdr a) (key (cadr a)) b kcarb)))))
  101.   (cond ((null? a) b)
  102.     ((null? b) a)
  103.     (else
  104.      (let ((kcara (key (car a)))
  105.            (kcarb (key (car b))))
  106.        (cond
  107.         ((less? kcarb kcara)
  108.          (if (null? (cdr b))
  109.          (set-cdr! b a)
  110.          (loop b a kcara (cdr b) (key (cadr b))))
  111.          b)
  112.         (else            ; (car a) <= (car b)
  113.          (if (null? (cdr a))
  114.          (set-cdr! a b)
  115.          (loop a (cdr a) (key (cadr a)) b kcarb))
  116.          a))))))
  117.  
  118. ;;; takes two sorted lists a and b and smashes their cdr fields to form a
  119. ;;; single sorted list including the elements of both.
  120. ;;; Note:  this does _not_ accept arrays.
  121. ;@
  122. (define (merge! a b less? . opt-key)
  123.   (sort:merge! a b less? (if (null? opt-key) identity (car opt-key))))
  124.  
  125. (define (sort:sort-list! seq less? key)
  126.   (define keyer (if key car identity))
  127.   (define (step n)
  128.     (cond ((> n 2) (let* ((j (quotient n 2))
  129.               (a (step j))
  130.               (k (- n j))
  131.               (b (step k)))
  132.              (sort:merge! a b less? keyer)))
  133.       ((= n 2) (let ((x (car seq))
  134.              (y (cadr seq))
  135.              (p seq))
  136.              (set! seq (cddr seq))
  137.              (cond ((less? (keyer y) (keyer x))
  138.                 (set-car! p y)
  139.                 (set-car! (cdr p) x)))
  140.              (set-cdr! (cdr p) '())
  141.              p))
  142.       ((= n 1) (let ((p seq))
  143.              (set! seq (cdr seq))
  144.              (set-cdr! p '())
  145.              p))
  146.       (else '())))
  147.   (define (key-wrap! lst)
  148.     (cond ((null? lst))
  149.       (else (set-car! lst (cons (key (car lst)) (car lst)))
  150.         (key-wrap! (cdr lst)))))
  151.   (define (key-unwrap! lst)
  152.     (cond ((null? lst))
  153.       (else (set-car! lst (cdar lst))
  154.         (key-unwrap! (cdr lst)))))
  155.   (cond (key
  156.      (key-wrap! seq)
  157.      (set! seq (step (length seq)))
  158.      (key-unwrap! seq)
  159.      seq)
  160.     (else
  161.      (step (length seq)))))
  162.  
  163. (define (rank-1-array->list array)
  164.   (define dimensions (array-dimensions array))
  165.   (do ((idx (+ -1 (car dimensions)) (+ -1 idx))
  166.        (lst '() (cons (array-ref array idx) lst)))
  167.       ((< idx 0) lst)))
  168.  
  169. ;;; (sort! sequence less?)
  170. ;;; sorts the list, array, or string sequence destructively.  It uses
  171. ;;; a version of merge-sort invented, to the best of my knowledge, by
  172. ;;; David H. D. Warren, and first used in the DEC-10 Prolog system.
  173. ;;; R. A. O'Keefe adapted it to work destructively in Scheme.
  174. ;;; A. Jaffer modified to always return the original list.
  175. ;@
  176. (define (sort! seq less? . opt-key)
  177.   (define key (if (null? opt-key) #f (car opt-key)))
  178.   (cond ((array? seq)
  179.      (let ((dims (array-dimensions seq)))
  180.        (do ((sorted (sort:sort-list! (rank-1-array->list seq) less? key)
  181.             (cdr sorted))
  182.         (i 0 (+ i 1)))
  183.            ((null? sorted) seq)
  184.          (array-set! seq (car sorted) i))))
  185.     (else                  ; otherwise, assume it is a list
  186.      (let ((ret (sort:sort-list! seq less? key)))
  187.        (if (not (eq? ret seq))
  188.            (do ((crt ret (cdr crt)))
  189.            ((eq? (cdr crt) seq)
  190.             (set-cdr! crt ret)
  191.             (let ((scar (car seq)) (scdr (cdr seq)))
  192.               (set-car! seq (car ret)) (set-cdr! seq (cdr ret))
  193.               (set-car! ret scar) (set-cdr! ret scdr)))))
  194.        seq))))
  195.  
  196. ;;; (sort sequence less?)
  197. ;;; sorts a array, string, or list non-destructively.  It does this
  198. ;;; by sorting a copy of the sequence.  My understanding is that the
  199. ;;; Standard says that the result of append is always "newly
  200. ;;; allocated" except for sharing structure with "the last argument",
  201. ;;; so (append x '()) ought to be a standard way of copying a list x.
  202. ;@
  203. (define (sort seq less? . opt-key)
  204.   (define key (if (null? opt-key) #f (car opt-key)))
  205.   (cond ((array? seq)
  206.      (let ((dims (array-dimensions seq)))
  207.        (define newra (apply make-array seq dims))
  208.        (do ((sorted (sort:sort-list! (rank-1-array->list seq) less? key)
  209.             (cdr sorted))
  210.         (i 0 (+ i 1)))
  211.            ((null? sorted) newra)
  212.          (array-set! newra (car sorted) i))))
  213.     (else (sort:sort-list! (append seq '()) less? key))))
  214.